Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue39/construc/VISITORX.PAS

Pascal/Delphi Source File | 1998-10-06 | 11.6 KB | 445 lines

unit VisitorX;
// 194.229.217.93
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ActiveX, AxCtrls, VisitBob_TLB, Db, ExtCtrls, Grids, DBGrids, StdCtrls, Buttons,
  DBClient;

type
  TVisitorTrackingX = class(TActiveForm, IVisitorTrackingX)
    Panel1: TPanel;
    ClientDataSet1: TClientDataSet;
    DataSource1: TDataSource;
    DBGrid1: TDBGrid;
    BitBtnConnect: TBitBtn;
    BitBtnPaths: TBitBtn;
    BitBtnStats: TBitBtn;
    procedure BitBtnConnectClick(Sender: TObject);
    procedure DBGrid1DblClick(Sender: TObject);
    procedure DBGrid1CellClick(Column: TColumn);
    procedure BitBtnPathsClick(Sender: TObject);
    procedure BitBtnStatsClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    FEvents: IVisitorTrackingXEvents;
    procedure ActivateEvent(Sender: TObject);
    procedure ClickEvent(Sender: TObject);
    procedure CreateEvent(Sender: TObject);
    procedure DblClickEvent(Sender: TObject);
    procedure DeactivateEvent(Sender: TObject);
    procedure DestroyEvent(Sender: TObject);
    procedure KeyPressEvent(Sender: TObject; var Key: Char);
    procedure PaintEvent(Sender: TObject);
  protected
    { Protected declarations }
    procedure DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage); override;
    procedure EventSinkChanged(const EventSink: IUnknown); override;
    function Get_Active: WordBool; safecall;
    function Get_AutoScroll: WordBool; safecall;
    function Get_AutoSize: WordBool; safecall;
    function Get_AxBorderStyle: TxActiveFormBorderStyle; safecall;
    function Get_BiDiMode: TxBiDiMode; safecall;
    function Get_Caption: WideString; safecall;
    function Get_Color: OLE_COLOR; safecall;
    function Get_Cursor: Smallint; safecall;
    function Get_DoubleBuffered: WordBool; safecall;
    function Get_DropTarget: WordBool; safecall;
    function Get_Enabled: WordBool; safecall;
    function Get_Font: IFontDisp; safecall;
    function Get_HelpFile: WideString; safecall;
    function Get_KeyPreview: WordBool; safecall;
    function Get_PixelsPerInch: Integer; safecall;
    function Get_PrintScale: TxPrintScale; safecall;
    function Get_Scaled: WordBool; safecall;
    function Get_Visible: WordBool; safecall;
    procedure _Set_Font(const Value: IFontDisp); safecall;
    procedure Set_AutoScroll(Value: WordBool); safecall;
    procedure Set_AutoSize(Value: WordBool); safecall;
    procedure Set_AxBorderStyle(Value: TxActiveFormBorderStyle); safecall;
    procedure Set_BiDiMode(Value: TxBiDiMode); safecall;
    procedure Set_Caption(const Value: WideString); safecall;
    procedure Set_Color(Value: OLE_COLOR); safecall;
    procedure Set_Cursor(Value: Smallint); safecall;
    procedure Set_DoubleBuffered(Value: WordBool); safecall;
    procedure Set_DropTarget(Value: WordBool); safecall;
    procedure Set_Enabled(Value: WordBool); safecall;
    procedure Set_Font(var Value: IFontDisp); safecall;
    procedure Set_HelpFile(const Value: WideString); safecall;
    procedure Set_KeyPreview(Value: WordBool); safecall;
    procedure Set_PixelsPerInch(Value: Integer); safecall;
    procedure Set_PrintScale(Value: TxPrintScale); safecall;
    procedure Set_Scaled(Value: WordBool); safecall;
    procedure Set_Visible(Value: WordBool); safecall;
  public
    { Public declarations }
    procedure Initialize; override;
  end;

implementation
uses
  ComObj, ComServ;

{$R *.DFM}

{ TVisitorTrackingX }

procedure TVisitorTrackingX.DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage);
begin
  { Define property pages here.  Property pages are defined by calling
    DefinePropertyPage with the class id of the page.  For example,
      DefinePropertyPage(Class_VisitorTrackingXPage); }
end;

procedure TVisitorTrackingX.EventSinkChanged(const EventSink: IUnknown);
begin
  FEvents := EventSink as IVisitorTrackingXEvents;
end;

procedure TVisitorTrackingX.Initialize;
begin
  inherited Initialize;
  OnActivate := ActivateEvent;
  OnClick := ClickEvent;
  OnCreate := CreateEvent;
  OnDblClick := DblClickEvent;
  OnDeactivate := DeactivateEvent;
  OnDestroy := DestroyEvent;
  OnKeyPress := KeyPressEvent;
  OnPaint := PaintEvent;
end;

function TVisitorTrackingX.Get_Active: WordBool;
begin
  Result := Active;
end;

function TVisitorTrackingX.Get_AutoScroll: WordBool;
begin
  Result := AutoScroll;
end;

function TVisitorTrackingX.Get_AutoSize: WordBool;
begin
  Result := AutoSize;
end;

function TVisitorTrackingX.Get_AxBorderStyle: TxActiveFormBorderStyle;
begin
  Result := Ord(AxBorderStyle);
end;

function TVisitorTrackingX.Get_BiDiMode: TxBiDiMode;
begin
  Result := Ord(BiDiMode);
end;

function TVisitorTrackingX.Get_Caption: WideString;
begin
  Result := WideString(Caption);
end;

function TVisitorTrackingX.Get_Color: OLE_COLOR;
begin
  Result := OLE_COLOR(Color);
end;

function TVisitorTrackingX.Get_Cursor: Smallint;
begin
  Result := Smallint(Cursor);
end;

function TVisitorTrackingX.Get_DoubleBuffered: WordBool;
begin
  Result := DoubleBuffered;
end;

function TVisitorTrackingX.Get_DropTarget: WordBool;
begin
  Result := DropTarget;
end;

function TVisitorTrackingX.Get_Enabled: WordBool;
begin
  Result := Enabled;
end;

function TVisitorTrackingX.Get_Font: IFontDisp;
begin
  GetOleFont(Font, Result);
end;

function TVisitorTrackingX.Get_HelpFile: WideString;
begin
  Result := WideString(HelpFile);
end;

function TVisitorTrackingX.Get_KeyPreview: WordBool;
begin
  Result := KeyPreview;
end;

function TVisitorTrackingX.Get_PixelsPerInch: Integer;
begin
  Result := PixelsPerInch;
end;

function TVisitorTrackingX.Get_PrintScale: TxPrintScale;
begin
  Result := Ord(PrintScale);
end;

function TVisitorTrackingX.Get_Scaled: WordBool;
begin
  Result := Scaled;
end;

function TVisitorTrackingX.Get_Visible: WordBool;
begin
  Result := Visible;
end;

procedure TVisitorTrackingX._Set_Font(const Value: IFontDisp);
begin
  SetOleFont(Font, Value);
end;

procedure TVisitorTrackingX.Set_AutoScroll(Value: WordBool);
begin
  AutoScroll := Value;
end;

procedure TVisitorTrackingX.Set_AutoSize(Value: WordBool);
begin
  AutoSize := Value;
end;

procedure TVisitorTrackingX.Set_AxBorderStyle(
  Value: TxActiveFormBorderStyle);
begin
  AxBorderStyle := TActiveFormBorderStyle(Value);
end;

procedure TVisitorTrackingX.Set_BiDiMode(Value: TxBiDiMode);
begin
  BiDiMode := TBiDiMode(Value);
end;

procedure TVisitorTrackingX.Set_Caption(const Value: WideString);
begin
  Caption := TCaption(Value);
end;

procedure TVisitorTrackingX.Set_Color(Value: OLE_COLOR);
begin
  Color := TColor(Value);
end;

procedure TVisitorTrackingX.Set_Cursor(Value: Smallint);
begin
  Cursor := TCursor(Value);
end;

procedure TVisitorTrackingX.Set_DoubleBuffered(Value: WordBool);
begin
  DoubleBuffered := Value;
end;

procedure TVisitorTrackingX.Set_DropTarget(Value: WordBool);
begin
  DropTarget := Value;
end;

procedure TVisitorTrackingX.Set_Enabled(Value: WordBool);
begin
  Enabled := Value;
end;

procedure TVisitorTrackingX.Set_Font(var Value: IFontDisp);
begin
  SetOleFont(Font, Value);
end;

procedure TVisitorTrackingX.Set_HelpFile(const Value: WideString);
begin
  HelpFile := String(Value);
end;

procedure TVisitorTrackingX.Set_KeyPreview(Value: WordBool);
begin
  KeyPreview := Value;
end;

procedure TVisitorTrackingX.Set_PixelsPerInch(Value: Integer);
begin
  PixelsPerInch := Value;
end;

procedure TVisitorTrackingX.Set_PrintScale(Value: TxPrintScale);
begin
  PrintScale := TPrintScale(Value);
end;

procedure TVisitorTrackingX.Set_Scaled(Value: WordBool);
begin
  Scaled := Value;
end;

procedure TVisitorTrackingX.Set_Visible(Value: WordBool);
begin
  Visible := Value;
end;

procedure TVisitorTrackingX.ActivateEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnActivate;
end;

procedure TVisitorTrackingX.ClickEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnClick;
end;

procedure TVisitorTrackingX.CreateEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnCreate;
end;

procedure TVisitorTrackingX.DblClickEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnDblClick;
end;

procedure TVisitorTrackingX.DeactivateEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnDeactivate;
end;

procedure TVisitorTrackingX.DestroyEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnDestroy;
end;

procedure TVisitorTrackingX.KeyPressEvent(Sender: TObject; var Key: Char);
var
  TempKey: Smallint;
begin
  TempKey := Smallint(Key);
  if FEvents <> nil then FEvents.OnKeyPress(TempKey);
  Key := Char(TempKey);
end;

procedure TVisitorTrackingX.PaintEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnPaint;
end;


const
  F_DT = 0; { date/time }
  F_IP = 1; { IP-address }
  F_UA = 2; { User Agent }
  F_URL = 3; { current URL }
  F_REF = 4; { referrer }

procedure TVisitorTrackingX.FormCreate(Sender: TObject);
begin
{$IFDEF LIVE}
  ClientDataSet1.RemoteServer := DCOMConnection1;
  ClientDataSet1.ProviderName := 'Provider1'
{$ENDIF}
end;

procedure TVisitorTrackingX.BitBtnConnectClick(Sender: TObject);
begin
  if (Sender as TBitBtn).Caption = '&Connect' then
  begin
    (Sender as TBitBtn).Caption := '&Disconnect';
  {$IFDEF LIVE}
    DCOMConnection1.Connected := True;
  {$ENDIF}
    ClientDataSet1.Active := True
  end
  else { disconnect }
  begin
    ClientDataSet1.Active := False;
  {$IFDEF LIVE}
    DCOMConnection1.Connected := False;
  {$ENDIF}
    (Sender as TBitBtn).Caption := '&Connect'
  end;
  BitBtnPaths.Enabled := ClientDataSet1.Active;
  BitBtnStats.Enabled := ClientDataSet1.Active
end;

var
  ColumnTitleCaption: String;

procedure TVisitorTrackingX.DBGrid1CellClick(Column: TColumn);
begin
  ColumnTitleCaption := Column.Title.Caption
end;

procedure TVisitorTrackingX.DBGrid1DblClick(Sender: TObject);
begin
  ClientDataSet1.IndexFieldNames :=
    ColumnTitleCaption + ';DateTime'
end;

procedure TVisitorTrackingX.BitBtnPathsClick(Sender: TObject);
begin
  if ClientDataSet1.Filtered then
  begin
    DBGrid1.Columns[F_UA].Visible := True;
    ClientDataSet1.Filtered := False
  end
  else
  begin
    ClientDataSet1.Filter := 'IP = ' +
      ClientDataSet1.FieldByName('IP').AsString;
    DBGrid1.Columns[F_UA].Visible := False;
    ClientDataSet1.Filtered := True
  end
end;

procedure TVisitorTrackingX.BitBtnStatsClick(Sender: TObject);
var
  Info,UserAgent: String;
  i: Integer;
begin
  Info := '';
  ClientDataSet1.IndexFieldNames := 'UserAgent;DateTime';
  UserAgent := '';
  i := 0;
  ClientDataSet1.First;
  while not ClientDataSet1.Eof do
  begin
    if ClientDataSet1.Fields[F_UA].AsString <> UserAgent then
    begin
      if (i > 0) and (Length(UserAgent) < 88) then
        Info := Info + IntToStr(i)+' - '+UserAgent + #13#10;
      if Pos('MS ',ClientDataSet1.Fields[F_UA].AsString) > 0 then
        Info := Info + #13#10; { entire new browser type }
      i := 1; { first time this browser is used }
      UserAgent := ClientDataSet1.Fields[F_UA].AsString
    end
    else Inc(i);
    ClientDataSet1.Next { don't forget this statement!! }
  end;
  ClientDataSet1.First;
  MessageDlg(Info,mtInformation,[mbOk],0)
end;

initialization
  TActiveFormFactory.Create(
    ComServer,
    TActiveFormControl,
    TVisitorTrackingX,
    Class_VisitorTrackingX,
    1,
    '',
    OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
    tmApartment);
end.